home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xleval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  21.1 KB  |  911 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xleval.c
  5. * RCS:          $Header: xleval.c,v 1.5 91/03/24 22:24:36 mayer Exp $
  6. * Description:  xlisp evaluator
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 03:51:24 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xleval.c,v 1.5 91/03/24 22:24:36 mayer Exp $";
  43.  
  44. #include "xlisp.h"
  45.  
  46. /* macro to check for lambda list keywords */
  47. #define iskey(s) ((s) == lk_optional \
  48.                || (s) == lk_rest \
  49.                || (s) == lk_key \
  50.                || (s) == lk_aux \
  51.                || (s) == lk_allow_other_keys)
  52.  
  53. /* macros to handle tracing */
  54. #define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
  55. #define trexit(sym,val) {if (sym) doexit(sym,val);}
  56.  
  57. /* external variables */
  58. extern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
  59. extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
  60. extern LVAL s_evalhook,s_applyhook,s_tracelist;
  61. extern LVAL s_lambda,s_macro;
  62. extern LVAL s_unbound;
  63. extern int xlsample;
  64. extern char buf[];
  65.  
  66. /* forward declarations */
  67. FORWARD LVAL xlxeval();
  68. LOCAL FORWARD LVAL evalhook();    /* NPM: changed this to LOCAL */
  69. LOCAL FORWARD LVAL evform();    /* NPM: changed this to LOCAL */
  70. LOCAL FORWARD LVAL evfun();    /* NPM: changed this to LOCAL */
  71.  
  72. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  73. LVAL xleval(expr)
  74.   LVAL expr;
  75. {
  76.     /* check for control codes */
  77.     if (--xlsample <= 0) {
  78.     xlsample = SAMPLE;
  79.     oscheck();
  80.     }
  81.  
  82.     /* check for *evalhook* */
  83.     if (getvalue(s_evalhook))
  84.     return (evalhook(expr));
  85.  
  86.     /* check for nil */
  87.     if (null(expr))
  88.     return (NIL);
  89.  
  90.     /* dispatch on the node type */
  91.     switch (ntype(expr)) {
  92.     case CONS:
  93.     return (evform(expr));
  94.     case SYMBOL:
  95.     return (xlgetvalue(expr));
  96.     default:
  97.     return (expr);
  98.     }
  99. }
  100.  
  101. /* xlevalenv - evaluate an expression in a specified environment */
  102. LVAL xlevalenv(expr,env,fenv)
  103.   LVAL expr,env,fenv;
  104. {
  105.     LVAL oldenv,oldfenv,val;
  106.  
  107.     /* protect some pointers */
  108.     xlstkcheck(2);
  109.     xlsave(oldenv);
  110.     xlsave(oldfenv);
  111.  
  112.     /* establish the new environment */
  113.     oldenv = xlenv;
  114.     oldfenv = xlfenv;
  115.     xlenv = env;
  116.     xlfenv = fenv;
  117.  
  118.     /* evaluate the expression */
  119.     val = xleval(expr);
  120.  
  121.     /* restore the environment */
  122.     xlenv = oldenv;
  123.     xlfenv = oldfenv;
  124.  
  125.     /* restore the stack */
  126.     xlpopn(2);
  127.  
  128.     /* return the result value */
  129.     return (val);
  130. }
  131.  
  132. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  133. LVAL xlxeval(expr)
  134.   LVAL expr;
  135. {
  136.     /* check for nil */
  137.     if (null(expr))
  138.     return (NIL);
  139.  
  140.     /* dispatch on node type */
  141.     switch (ntype(expr)) {
  142.     case CONS:
  143.     return (evform(expr));
  144.     case SYMBOL:
  145.     return (xlgetvalue(expr));
  146.     default:
  147.     return (expr);
  148.     }
  149. }
  150.  
  151. /* xlapply - apply a function to arguments (already on the stack) */
  152. LVAL xlapply(argc)
  153.   int argc;
  154. {
  155.     LVAL *oldargv,fun,val;
  156.     int oldargc;
  157.     
  158.     /* get the function */
  159.     fun = xlfp[1];
  160.  
  161.     /* get the functional value of symbols */
  162.     if (symbolp(fun)) {
  163.     while ((val = getfunction(fun)) == s_unbound)
  164.         xlfunbound(fun);
  165.     fun = xlfp[1] = val;
  166.     }
  167.  
  168.     /* check for nil */
  169.     if (null(fun))
  170.     xlerror("bad function",fun);
  171.  
  172.     /* dispatch on node type */
  173.     switch (ntype(fun)) {
  174.     case SUBR:
  175.     oldargc = xlargc;
  176.     oldargv = xlargv;
  177.     xlargc = argc;
  178.     xlargv = xlfp + 3;
  179.     val = (*getsubr(fun))();
  180.     xlargc = oldargc;
  181.     xlargv = oldargv;
  182.     break;
  183.     case CONS:
  184.     if (!consp(cdr(fun)))
  185.         xlerror("bad function",fun);
  186.     if (car(fun) == s_lambda)
  187.         fun = xlclose(NIL,
  188.                       s_lambda,
  189.                       car(cdr(fun)),
  190.                       cdr(cdr(fun)),
  191.                       xlenv,xlfenv);
  192.     else
  193.         xlerror("bad function",fun);
  194.     /**** fall through into the next case ****/
  195.     case CLOSURE:
  196.     if (gettype(fun) != s_lambda)
  197.         xlerror("bad function",fun);
  198.     val = evfun(fun,argc,xlfp+3);
  199.     break;
  200.     default:
  201.     xlerror("bad function",fun);
  202.     }
  203.  
  204.     /* remove the call frame */
  205.     xlsp = xlfp;
  206.     xlfp = xlfp - (int)getfixnum(*xlfp);
  207.  
  208.     /* return the function value */
  209.     return (val);
  210. }
  211.  
  212. /* evform - evaluate a form */
  213. LOCAL LVAL evform(form)
  214.   LVAL form;
  215. {
  216.     LVAL fun,args,val,type;
  217.     LVAL tracing=NIL;
  218.     LVAL *argv;
  219.     int argc;
  220.  
  221.     /* protect some pointers */
  222.     xlstkcheck(2);
  223.     xlsave(fun);
  224.     xlsave(args);
  225.  
  226.     /* get the function and the argument list */
  227.     fun = car(form);
  228.     args = cdr(form);
  229.  
  230.     /* get the functional value of symbols */
  231.     if (symbolp(fun)) {
  232.     if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
  233.         tracing = fun;
  234.     fun = xlgetfunction(fun);
  235.     }
  236.  
  237.     /* check for nil */
  238.     if (null(fun))
  239.     xlerror("bad function",NIL);
  240.  
  241.     /* dispatch on node type */
  242.     switch (ntype(fun)) {
  243.     case SUBR:
  244.     argv = xlargv;
  245.     argc = xlargc;
  246.     xlargc = evpushargs(fun,args);
  247.     xlargv = xlfp + 3;
  248.     trenter(tracing,xlargc,xlargv);
  249.     val = (*getsubr(fun))();
  250.     trexit(tracing,val);
  251.     xlsp = xlfp;
  252.     xlfp = xlfp - (int)getfixnum(*xlfp);
  253.     xlargv = argv;
  254.     xlargc = argc;
  255.     break;
  256.     case FSUBR:
  257.     argv = xlargv;
  258.     argc = xlargc;
  259.     xlargc = pushargs(fun,args);
  260.     xlargv = xlfp + 3;
  261.     val = (*getsubr(fun))();
  262.     xlsp = xlfp;
  263.     xlfp = xlfp - (int)getfixnum(*xlfp);
  264.     xlargv = argv;
  265.     xlargc = argc;
  266.     break;
  267.     case CONS:
  268.     if (!consp(cdr(fun)))
  269.         xlerror("bad function",fun);
  270.     if ((type = car(fun)) == s_lambda)
  271.          fun = xlclose(NIL,
  272.                        s_lambda,
  273.                        car(cdr(fun)),
  274.                        cdr(cdr(fun)),
  275.                        xlenv,xlfenv);
  276.     else
  277.         xlerror("bad function",fun);
  278.     /**** fall through into the next case ****/
  279.     case CLOSURE:
  280.     if (gettype(fun) == s_lambda) {
  281.         argc = evpushargs(fun,args);
  282.         argv = xlfp + 3;
  283.         trenter(tracing,argc,argv);
  284.         val = evfun(fun,argc,argv);
  285.         trexit(tracing,val);
  286.         xlsp = xlfp;
  287.         xlfp = xlfp - (int)getfixnum(*xlfp);
  288.     }
  289.     else {
  290.         macroexpand(fun,args,&fun);
  291.         val = xleval(fun);
  292.     }
  293.     break;
  294.     default:
  295.     xlerror("bad function",fun);
  296.     }
  297.  
  298.     /* restore the stack */
  299.     xlpopn(2);
  300.  
  301.     /* return the result value */
  302.     return (val);
  303. }
  304.  
  305. /* xlexpandmacros - expand macros in a form */
  306. LVAL xlexpandmacros(form)
  307.   LVAL form;
  308. {
  309.     LVAL fun,args;
  310.     
  311.     /* protect some pointers */
  312.     xlstkcheck(3);
  313.     xlprotect(form);
  314.     xlsave(fun);
  315.     xlsave(args);
  316.  
  317.     /* expand until the form isn't a macro call */
  318.     while (consp(form)) {
  319.     fun = car(form);        /* get the macro name */
  320.     args = cdr(form);        /* get the arguments */
  321.     if (!symbolp(fun) || !fboundp(fun))
  322.         break;
  323.     fun = xlgetfunction(fun);    /* get the expansion function */
  324.     if (!macroexpand(fun,args,&form))
  325.         break;
  326.     }
  327.  
  328.     /* restore the stack and return the expansion */
  329.     xlpopn(3);
  330.     return (form);
  331. }
  332.  
  333. /* macroexpand - expand a macro call */
  334. int macroexpand(fun,args,pval)
  335.   LVAL fun,args,*pval;
  336. {
  337.     LVAL *argv;
  338.     int argc;
  339.     
  340.     /* make sure it's really a macro call */
  341.     if (!closurep(fun) || gettype(fun) != s_macro)
  342.     return (FALSE);
  343.     
  344.     /* call the expansion function */
  345.     argc = pushargs(fun,args);
  346.     argv = xlfp + 3;
  347.     *pval = evfun(fun,argc,argv);
  348.     xlsp = xlfp;
  349.     xlfp = xlfp - (int)getfixnum(*xlfp);
  350.     return (TRUE);
  351. }
  352.  
  353. /* evalhook - call the evalhook function */
  354. LOCAL LVAL evalhook(expr)
  355.   LVAL expr;
  356. {
  357.     LVAL *newfp,olddenv,val;
  358.  
  359.     /* create the new call frame */
  360.     newfp = xlsp;
  361.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  362.     pusharg(getvalue(s_evalhook));
  363.     pusharg(cvfixnum((FIXTYPE)2));
  364.     pusharg(expr);
  365.     pusharg(cons(xlenv,xlfenv));
  366.     xlfp = newfp;
  367.  
  368.     /* rebind the hook functions to nil */
  369.     olddenv = xldenv;
  370.     xldbind(s_evalhook,NIL);
  371.     xldbind(s_applyhook,NIL);
  372.  
  373.     /* call the hook function */
  374.     val = xlapply(2);
  375.  
  376.     /* unbind the symbols */
  377.     xlunbind(olddenv);
  378.  
  379.     /* return the value */
  380.     return (val);
  381. }
  382.  
  383. /* evpushargs - evaluate and push a list of arguments */
  384. LOCAL int evpushargs(fun,args)
  385.   LVAL fun,args;
  386. {
  387.     LVAL *newfp;
  388.     int argc;
  389.     
  390.     /* protect the argument list */
  391.     xlprot1(args);
  392.  
  393.     /* build a new argument stack frame */
  394.     newfp = xlsp;
  395.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  396.     pusharg(fun);
  397.     pusharg(NIL); /* will be argc */
  398.  
  399.     /* evaluate and push each argument */
  400.     for (argc = 0; consp(args); args = cdr(args), ++argc)
  401.     pusharg(xleval(car(args)));
  402.  
  403.     /* establish the new stack frame */
  404.     newfp[2] = cvfixnum((FIXTYPE)argc);
  405.     xlfp = newfp;
  406.     
  407.     /* restore the stack */
  408.     xlpop();
  409.  
  410.     /* return the number of arguments */
  411.     return (argc);
  412. }
  413.  
  414. /* pushargs - push a list of arguments */
  415. int pushargs(fun,args)
  416.   LVAL fun,args;
  417. {
  418.     LVAL *newfp;
  419.     int argc;
  420.     
  421.     /* build a new argument stack frame */
  422.     newfp = xlsp;
  423.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  424.     pusharg(fun);
  425.     pusharg(NIL); /* will be argc */
  426.  
  427.     /* push each argument */
  428.     for (argc = 0; consp(args); args = cdr(args), ++argc)
  429.     pusharg(car(args));
  430.  
  431.     /* establish the new stack frame */
  432.     newfp[2] = cvfixnum((FIXTYPE)argc);
  433.     xlfp = newfp;
  434.  
  435.     /* return the number of arguments */
  436.     return (argc);
  437. }
  438.  
  439. /* makearglist - make a list of the remaining arguments */
  440. LVAL makearglist(argc,argv)
  441.   int argc; LVAL *argv;
  442. {
  443.     LVAL list,this,last;
  444.     xlsave1(list);
  445.     for (last = NIL; --argc >= 0; last = this) {
  446.     this = cons(*argv++,NIL);
  447.     if (last) rplacd(last,this);
  448.     else list = this;
  449.      /* last = this; */ /* NPM: commented this out at request of jsp@glia.biostr.washington.edu (Jeff Prothero) */ 
  450.     }
  451.     xlpop();
  452.     return (list);
  453. }
  454.  
  455. /* evfun - evaluate a function */
  456. LOCAL LVAL evfun(fun,argc,argv)
  457.   LVAL fun; int argc; LVAL *argv;
  458. {
  459.     LVAL oldenv,oldfenv,cptr,name,val;
  460.     CONTEXT cntxt;
  461.  
  462.     /* protect some pointers */
  463.     xlstkcheck(3);
  464.     xlsave(oldenv);
  465.     xlsave(oldfenv);
  466.     xlsave(cptr);
  467.  
  468.     /* create a new environment frame */
  469.     oldenv = xlenv;
  470.     oldfenv = xlfenv;
  471. #ifdef WINTERP            /* note: changed getenv()-->getenvt() due to name conflict with stdlib.h:getenv() */
  472.     xlenv = xlframe(getenvt(fun));
  473. #else
  474.     xlenv = xlframe(getenv(fun));
  475. #endif                /* WINTERP */
  476.     xlfenv = getfenv(fun);
  477.  
  478.     /* bind the formal parameters */
  479.     xlabind(fun,argc,argv);
  480.  
  481.     /* setup the implicit block */
  482.     if (name = getname(fun))
  483.     xlbegin(&cntxt,CF_RETURN,name);
  484.  
  485.     /* execute the block */
  486.     if (name && setjmp(cntxt.c_jmpbuf))
  487.     val = xlvalue;
  488.     else
  489.     for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
  490.         val = xleval(car(cptr));
  491.  
  492.     /* finish the block context */
  493.     if (name)
  494.     xlend(&cntxt);
  495.  
  496.     /* restore the environment */
  497.     xlenv = oldenv;
  498.     xlfenv = oldfenv;
  499.  
  500.     /* restore the stack */
  501.     xlpopn(3);
  502.  
  503.     /* return the result value */
  504.     return (val);
  505. }
  506.  
  507. /* xlclose - create a function closure */
  508. LVAL xlclose(name,type,fargs,body,env,fenv)
  509.   LVAL name,type,fargs,body,env,fenv;
  510. {
  511.     LVAL closure,key,arg,def,svar,new,last;
  512.     char keyname[STRMAX+2];
  513.  
  514.     /* protect some pointers */
  515.     xlsave1(closure);
  516.  
  517.     /* create the closure object */
  518.     closure = newclosure(name,type,env,fenv);
  519.     setlambda(closure,fargs);
  520.     setbody(closure,body);
  521.  
  522.     /* handle each required argument */
  523.     last = NIL;
  524.     while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
  525.  
  526.     /* make sure the argument is a symbol */
  527.     if (!symbolp(arg))
  528.         badarglist();
  529.  
  530.     /* create a new argument list entry */
  531.     new = cons(arg,NIL);
  532.  
  533.     /* link it into the required argument list */
  534.     if (last)
  535.         rplacd(last,new);
  536.     else
  537.         setargs(closure,new);
  538.     last = new;
  539.  
  540.     /* move the formal argument list pointer ahead */
  541.     fargs = cdr(fargs);
  542.     }
  543.  
  544.     /* check for the '&optional' keyword */
  545.     if (consp(fargs) && car(fargs) == lk_optional) {
  546.     fargs = cdr(fargs);
  547.  
  548.     /* handle each optional argument */
  549.     last = NIL;
  550.     while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
  551.  
  552.         /* get the default expression and specified-p variable */
  553.         def = svar = NIL;
  554.         if (consp(arg)) {
  555.         if (def = cdr(arg))
  556.             if (consp(def)) {
  557.             if (svar = cdr(def))
  558.                 if (consp(svar)) {
  559.                 svar = car(svar);
  560.                 if (!symbolp(svar))
  561.                     badarglist();
  562.                 }
  563.                 else
  564.                 badarglist();
  565.             def = car(def);
  566.             }
  567.             else
  568.             badarglist();
  569.         arg = car(arg);
  570.         }
  571.  
  572.         /* make sure the argument is a symbol */
  573.         if (!symbolp(arg))
  574.         badarglist();
  575.  
  576.         /* create a fully expanded optional expression */
  577.         new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);
  578.  
  579.         /* link it into the optional argument list */
  580.         if (last)
  581.         rplacd(last,new);
  582.         else
  583.         setoargs(closure,new);
  584.         last = new;
  585.         
  586.         /* move the formal argument list pointer ahead */
  587.         fargs = cdr(fargs);
  588.     }
  589.     }
  590.  
  591.     /* check for the '&rest' keyword */
  592.     if (consp(fargs) && car(fargs) == lk_rest) {
  593.     fargs = cdr(fargs);
  594.  
  595.     /* get the &rest argument */
  596.     if (consp(fargs) && (arg = car(fargs)) && !iskey(arg) && symbolp(arg))
  597.         setrest(closure,arg);
  598.     else
  599.         badarglist();
  600.  
  601.     /* move the formal argument list pointer ahead */
  602.     fargs = cdr(fargs);
  603.     }
  604.  
  605.     /* check for the '&key' keyword */
  606.     if (consp(fargs) && car(fargs) == lk_key) {
  607.     fargs = cdr(fargs);
  608.  
  609.      /* handle each key argument */
  610.     last = NIL;
  611.     while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
  612.  
  613.         /* get the default expression and specified-p variable */
  614.         def = svar = NIL;
  615.         if (consp(arg)) {
  616.         if (def = cdr(arg))
  617.             if (consp(def)) {
  618.             if (svar = cdr(def))
  619.                 if (consp(svar)) {
  620.                 svar = car(svar);
  621.                 if (!symbolp(svar))
  622.                     badarglist();
  623.                 }
  624.                 else
  625.                 badarglist();
  626.             def = car(def);
  627.             }
  628.             else
  629.             badarglist();
  630.         arg = car(arg);
  631.         }
  632.  
  633.         /* get the keyword and the variable */
  634.         if (consp(arg)) {
  635.         key = car(arg);
  636.         if (!symbolp(key))
  637.             badarglist();
  638.         if (arg = cdr(arg))
  639.             if (consp(arg))
  640.             arg = car(arg);
  641.             else
  642.             badarglist();
  643.         }
  644.         else if (symbolp(arg)) {
  645.         strcpy(keyname,":");
  646.         strcat(keyname,getstring(getpname(arg)));
  647.         key = xlenter(keyname);
  648.         }
  649.  
  650.         /* make sure the argument is a symbol */
  651.         if (!symbolp(arg))
  652.         badarglist();
  653.  
  654.         /* create a fully expanded key expression */
  655.         new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);
  656.  
  657.         /* link it into the optional argument list */
  658.         if (last)
  659.         rplacd(last,new);
  660.         else
  661.         setkargs(closure,new);
  662.         last = new;
  663.  
  664.         /* move the formal argument list pointer ahead */
  665.         fargs = cdr(fargs);
  666.     }
  667.     }
  668.  
  669.     /* check for the '&allow-other-keys' keyword */
  670.     if (consp(fargs) && car(fargs) == lk_allow_other_keys)
  671.     fargs = cdr(fargs);    /* this is the default anyway */
  672.  
  673.     /* check for the '&aux' keyword */
  674.     if (consp(fargs) && car(fargs) == lk_aux) {
  675.     fargs = cdr(fargs);
  676.  
  677.     /* handle each aux argument */
  678.     last = NIL;
  679.     while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
  680.  
  681.         /* get the initial value */
  682.         def = NIL;
  683.         if (consp(arg)) {
  684.         if (def = cdr(arg))
  685.             if (consp(def))
  686.             def = car(def);
  687.             else
  688.             badarglist();
  689.         arg = car(arg);
  690.         }
  691.  
  692.         /* make sure the argument is a symbol */
  693.         if (!symbolp(arg))
  694.         badarglist();
  695.  
  696.         /* create a fully expanded aux expression */
  697.         new = cons(cons(arg,cons(def,NIL)),NIL);
  698.  
  699.         /* link it into the aux argument list */
  700.         if (last)
  701.         rplacd(last,new);
  702.         else
  703.         setaargs(closure,new);
  704.         last = new;
  705.  
  706.         /* move the formal argument list pointer ahead */
  707.         fargs = cdr(fargs);
  708.     }
  709.     }
  710.  
  711.     /* make sure this is the end of the formal argument list */
  712.     if (fargs)
  713.     badarglist();
  714.  
  715.     /* restore the stack */
  716.     xlpop();
  717.  
  718.     /* return the new closure */
  719.     return (closure);
  720. }
  721.  
  722. /* xlabind - bind the arguments for a function */
  723. xlabind(fun,argc,argv)
  724.   LVAL fun; int argc; LVAL *argv;
  725. {
  726.     LVAL *kargv,fargs,key,arg,def,svar,p;
  727.     int rargc,kargc;
  728.     
  729.     /* protect some pointers */
  730.     xlsave1(def);
  731.  
  732.     /* bind each required argument */
  733.     for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {
  734.  
  735.     /* make sure there is an actual argument */
  736.     if (--argc < 0)
  737.         xlfail("too few arguments");
  738.  
  739.     /* bind the formal variable to the argument value */
  740.     xlbind(car(fargs),*argv++);
  741.     }
  742.  
  743.     /* bind each optional argument */
  744.     for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {
  745.  
  746.     /* get argument, default and specified-p variable */
  747.     p = car(fargs);
  748.     arg = car(p); p = cdr(p);
  749.     def = car(p); p = cdr(p);
  750.     svar = car(p);
  751.  
  752.     /* bind the formal variable to the argument value */
  753.     if (--argc >= 0) {
  754.         xlbind(arg,*argv++);
  755.         if (svar) xlbind(svar,true);
  756.     }
  757.  
  758.     /* bind the formal variable to the default value */
  759.     else {
  760.         if (def) def = xleval(def);
  761.         xlbind(arg,def);
  762.         if (svar) xlbind(svar,NIL);
  763.     }
  764.     }
  765.  
  766.     /* save the count of the &rest of the argument list */
  767.     rargc = argc;
  768.     
  769.     /* handle '&rest' argument */
  770.     if (arg = getrest(fun)) {
  771.     def = makearglist(argc,argv);
  772.     xlbind(arg,def);
  773.     argc = 0;
  774.     }
  775.  
  776.     /* handle '&key' arguments */
  777.     if (fargs = getkargs(fun)) {
  778.     for (; fargs; fargs = cdr(fargs)) {
  779.  
  780.         /* get keyword, argument, default and specified-p variable */
  781.         p = car(fargs);
  782.         key = car(p); p = cdr(p);
  783.         arg = car(p); p = cdr(p);
  784.         def = car(p); p = cdr(p);
  785.         svar = car(p);
  786.  
  787.         /* look for the keyword in the actual argument list */
  788.         for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
  789.         if (*kargv == key)
  790.             break;
  791.  
  792.         /* bind the formal variable to the argument value */
  793.         if (kargc >= 0) {
  794.         xlbind(arg,*++kargv);
  795.         if (svar) xlbind(svar,true);
  796.         }
  797.  
  798.         /* bind the formal variable to the default value */
  799.         else {
  800.         if (def) def = xleval(def);
  801.         xlbind(arg,def);
  802.         if (svar) xlbind(svar,NIL);
  803.         }
  804.     }
  805.     argc = 0;
  806.     }
  807.  
  808.     /* check for the '&aux' keyword */
  809.     for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {
  810.  
  811.     /* get argument and default */
  812.     p = car(fargs);
  813.     arg = car(p); p = cdr(p);
  814.     def = car(p);
  815.  
  816.     /* bind the auxiliary variable to the initial value */
  817.     if (def) def = xleval(def);
  818.     xlbind(arg,def);
  819.     }
  820.  
  821.     /* make sure there aren't too many arguments */
  822.     if (argc > 0)
  823.     xlfail("too many arguments");
  824.  
  825.     /* restore the stack */
  826.     xlpop();
  827. }
  828.  
  829. /* doenter - print trace information on function entry */
  830. LOCAL doenter(sym,argc,argv)
  831.   LVAL sym; int argc; LVAL *argv;
  832. {
  833.     extern int xltrcindent;
  834.     int i;
  835.     
  836.     /* indent to the current trace level */
  837.     for (i = 0; i < xltrcindent; ++i)
  838.     trcputstr(" ");
  839.     ++xltrcindent;
  840.  
  841.     /* display the function call */
  842.     sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym)));
  843.     trcputstr(buf);
  844.     while (--argc >= 0) {
  845.     trcprin1(*argv++);
  846.     if (argc) trcputstr(" ");
  847.     }
  848.     trcputstr(")\n");
  849. }
  850.  
  851. /* doexit - print trace information for function/macro exit */
  852. LOCAL doexit(sym,val)
  853.   LVAL sym,val;
  854. {
  855.     extern int xltrcindent;
  856.     int i;
  857.     
  858.     /* indent to the current trace level */
  859.     --xltrcindent;
  860.     for (i = 0; i < xltrcindent; ++i)
  861.     trcputstr(" ");
  862.     
  863.     /* display the function value */
  864.     sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym)));
  865.     trcputstr(buf);
  866.     trcprin1(val);
  867.     trcputstr("\n");
  868. }
  869.  
  870. /* member - is 'x' a member of 'list'? */
  871. LOCAL int member(x,list)
  872.   LVAL x,list;
  873. {
  874.     for (; consp(list); list = cdr(list))
  875.     if (x == car(list))
  876.         return (TRUE);
  877.     return (FALSE);
  878. }
  879.  
  880. /* xlunbound - signal an unbound variable error */
  881. xlunbound(sym)
  882.   LVAL sym;
  883. {
  884.     xlcerror("try evaluating symbol again","unbound variable",sym);
  885. }
  886.  
  887. /* xlfunbound - signal an unbound function error */
  888. xlfunbound(sym)
  889.   LVAL sym;
  890. {
  891.     xlcerror("try evaluating symbol again","unbound function",sym);
  892. }
  893.  
  894. /* xlstkoverflow - signal a stack overflow error */
  895. xlstkoverflow()
  896. {
  897.     xlabort("evaluation stack overflow");
  898. }
  899.  
  900. /* xlargstkoverflow - signal an argument stack overflow error */
  901. xlargstkoverflow()
  902. {
  903.     xlabort("argument stack overflow");
  904. }
  905.  
  906. /* badarglist - report a bad argument list error */
  907. LOCAL badarglist()
  908. {
  909.     xlfail("bad formal argument list");
  910. }
  911.